home *** CD-ROM | disk | FTP | other *** search
/ IRIS Performer 2.2 Friends Demo / SGI IRIS Performer 2.2 Friends Demo.iso / friends / openworlds / tcl / init.tcl next >
Text File  |  1997-11-22  |  16KB  |  552 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.57 96/07/23 08:53:03
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. if {[info commands package] == ""} {
  16.     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  17. }
  18. package require -exact Tcl 7.5
  19. if [catch {set auto_path $env(TCLLIBPATH)}] {
  20.     set auto_path ""
  21. }
  22. if {[lsearch -exact $auto_path [info library]] < 0} {
  23.     lappend auto_path [info library]
  24. }
  25. package unknown tclPkgUnknown
  26. if {[info commands exec] == ""} {
  27.  
  28.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  29.     # platforms, safe interpreters do not have exec.
  30.  
  31.     set auto_noexec 1
  32. }
  33. set errorCode ""
  34. set errorInfo ""
  35.  
  36. # unknown --
  37. # This procedure is called when a Tcl command is invoked that doesn't
  38. # exist in the interpreter.  It takes the following steps to make the
  39. # command available:
  40. #
  41. #    1. See if the autoload facility can locate the command in a
  42. #       Tcl script file.  If so, load it and execute it.
  43. #    2. If the command was invoked interactively at top-level:
  44. #        (a) see if the command exists as an executable UNIX program.
  45. #        If so, "exec" the command.
  46. #        (b) see if the command requests csh-like history substitution
  47. #        in one of the common forms !!, !<number>, or ^old^new.  If
  48. #        so, emulate csh's history substitution.
  49. #        (c) see if the command is a unique abbreviation for another
  50. #        command.  If so, invoke the command.
  51. #
  52. # Arguments:
  53. # args -    A list whose elements are the words of the original
  54. #        command, including the command name.
  55.  
  56. proc unknown args {
  57.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  58.     global errorCode errorInfo
  59.  
  60.     # Save the values of errorCode and errorInfo variables, since they
  61.     # may get modified if caught errors occur below.  The variables will
  62.     # be restored just before re-executing the missing command.
  63.  
  64.     set savedErrorCode $errorCode
  65.     set savedErrorInfo $errorInfo
  66.     set name [lindex $args 0]
  67.     if ![info exists auto_noload] {
  68.     #
  69.     # Make sure we're not trying to load the same proc twice.
  70.     #
  71.     if [info exists unknown_pending($name)] {
  72.         unset unknown_pending($name)
  73.         if {[array size unknown_pending] == 0} {
  74.         unset unknown_pending
  75.         }
  76.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  77.     }
  78.     set unknown_pending($name) pending;
  79.     set ret [catch {auto_load $name} msg]
  80.     unset unknown_pending($name);
  81.     if {$ret != 0} {
  82.         return -code $ret -errorcode $errorCode \
  83.         "error while autoloading \"$name\": $msg"
  84.     }
  85.     if ![array size unknown_pending] {
  86.         unset unknown_pending
  87.     }
  88.     if $msg {
  89.         set errorCode $savedErrorCode
  90.         set errorInfo $savedErrorInfo
  91.         set code [catch {uplevel $args} msg]
  92.         if {$code ==  1} {
  93.         #
  94.         # Strip the last five lines off the error stack (they're
  95.         # from the "uplevel" command).
  96.         #
  97.  
  98.         set new [split $errorInfo \n]
  99.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  100.         return -code error -errorcode $errorCode \
  101.             -errorinfo $new $msg
  102.         } else {
  103.         return -code $code $msg
  104.         }
  105.     }
  106.     }
  107.     if {([info level] == 1) && ([info script] == "") \
  108.         && [info exists tcl_interactive] && $tcl_interactive} {
  109.     if ![info exists auto_noexec] {
  110.         if [auto_execok $name] {
  111.         set errorCode $savedErrorCode
  112.         set errorInfo $savedErrorInfo
  113.         return [uplevel exec >&@stdout <@stdin $args]
  114.         }
  115.     }
  116.     set errorCode $savedErrorCode
  117.     set errorInfo $savedErrorInfo
  118.     if {$name == "!!"} {
  119.         return [uplevel {history redo}]
  120.     }
  121.     if [regexp {^!(.+)$} $name dummy event] {
  122.         return [uplevel [list history redo $event]]
  123.     }
  124.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  125.         return [uplevel [list history substitute $old $new]]
  126.     }
  127.     set cmds [info commands $name*]
  128.     if {[llength $cmds] == 1} {
  129.         return [uplevel [lreplace $args 0 0 $cmds]]
  130.     }
  131.     if {[llength $cmds] != 0} {
  132.         if {$name == ""} {
  133.         return -code error "empty command name \"\""
  134.         } else {
  135.         return -code error \
  136.             "ambiguous command name \"$name\": [lsort $cmds]"
  137.         }
  138.     }
  139.     }
  140.     return -code error "invalid command name \"$name\""
  141. }
  142.  
  143. # auto_load --
  144. # Checks a collection of library directories to see if a procedure
  145. # is defined in one of them.  If so, it sources the appropriate
  146. # library file to create the procedure.  Returns 1 if it successfully
  147. # loaded the procedure, 0 otherwise.
  148. #
  149. # Arguments: 
  150. # cmd -            Name of the command to find and load.
  151.  
  152. proc auto_load cmd {
  153.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  154.  
  155.     if [info exists auto_index($cmd)] {
  156.     uplevel #0 $auto_index($cmd)
  157.     return [expr {[info commands $cmd] != ""}]
  158.     }
  159.     if ![info exists auto_path] {
  160.     return 0
  161.     }
  162.     if [info exists auto_oldpath] {
  163.     if {$auto_oldpath == $auto_path} {
  164.         return 0
  165.     }
  166.     }
  167.     set auto_oldpath $auto_path
  168.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  169.     set dir [lindex $auto_path $i]
  170.     set f ""
  171.     if [catch {set f [open [file join $dir tclIndex]]}] {
  172.         continue
  173.     }
  174.     set error [catch {
  175.         set id [gets $f]
  176.         if {$id == "# Tcl autoload index file, version 2.0"} {
  177.         eval [read $f]
  178.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  179.         while {[gets $f line] >= 0} {
  180.             if {([string index $line 0] == "#")
  181.                 || ([llength $line] != 2)} {
  182.             continue
  183.             }
  184.             set name [lindex $line 0]
  185.             set auto_index($name) \
  186.             "source [file join $dir [lindex $line 1]]"
  187.         }
  188.         } else {
  189.         error "[file join $dir tclIndex] isn't a proper Tcl index file"
  190.         }
  191.     } msg]
  192.     if {$f != ""} {
  193.         close $f
  194.     }
  195.     if $error {
  196.         error $msg $errorInfo $errorCode
  197.     }
  198.     }
  199.     if [info exists auto_index($cmd)] {
  200.     uplevel #0 $auto_index($cmd)
  201.     if {[info commands $cmd] != ""} {
  202.         return 1
  203.     }
  204.     }
  205.     return 0
  206. }
  207.  
  208. if {[string compare $tcl_platform(platform) windows] == 0} {
  209.  
  210. # auto_execok --
  211. #
  212. # Returns 1 if there's an executable in the current path for the
  213. # given name, 0 otherwise.  Builds an associative array auto_execs
  214. # that caches information about previous checks, for speed.
  215. #
  216. # Arguments: 
  217. # name -            Name of a command.
  218.  
  219. # Windows version.
  220. #
  221. # Note that info executable doesn't work under Windows, so we have to
  222. # look for files with .exe, .com, or .bat extensions.  Also, the path
  223. # may be in the Path or PATH environment variables, and path
  224. # components are separated with semicolons, not colons as under Unix.
  225. #
  226. proc auto_execok name {
  227.     global auto_execs env
  228.  
  229.     if [info exists auto_execs($name)] {
  230.     return $auto_execs($name)
  231.     }
  232.     set auto_execs($name) 0
  233.     if {[file pathtype $name] != "relative"} {
  234.     foreach ext {{} .exe .bat .cmd} {
  235.         if {[file exists ${name}${ext}]
  236.         && ![file isdirectory ${name}${ext}]} {
  237.         set auto_execs($name) 1
  238.         }
  239.     }
  240.     return $auto_execs($name)
  241.     }
  242.     if {! [info exists env(PATH)]} {
  243.     if [info exists env(Path)] {
  244.         set path $env(Path)
  245.     } else {
  246.         return 0
  247.     }
  248.     } else {
  249.     set path $env(PATH)
  250.     }
  251.     foreach dir [split $path {;}] {
  252.     if {$dir == ""} {
  253.         set dir .
  254.     }
  255.     foreach ext {{} .exe .bat .cmd} {
  256.         set file [file join $dir ${name}${ext}]
  257.         if {[file exists $file] && ![file isdirectory $file]} {
  258.         set auto_execs($name) 1
  259.         return 1
  260.         }
  261.     }
  262.     }
  263.     return 0
  264. }
  265.  
  266. } else {
  267.  
  268. # Unix version.
  269. #
  270. proc auto_execok name {
  271.     global auto_execs env
  272.  
  273.     if [info exists auto_execs($name)] {
  274.     return $auto_execs($name)
  275.     }
  276.     set auto_execs($name) 0
  277.     if {[file pathtype $name] != "relative"} {
  278.     if {[file executable $name] && ![file isdirectory $name]} {
  279.         set auto_execs($name) 1
  280.     }
  281.     return $auto_execs($name)
  282.     }
  283.     foreach dir [split $env(PATH) :] {
  284.     if {$dir == ""} {
  285.         set dir .
  286.     }
  287.     set file [file join $dir $name]
  288.     if {[file executable $file] && ![file isdirectory $file]} {
  289.         set auto_execs($name) 1
  290.         return 1
  291.     }
  292.     }
  293.     return 0
  294. }
  295.  
  296. }
  297. # auto_reset --
  298. # Destroy all cached information for auto-loading and auto-execution,
  299. # so that the information gets recomputed the next time it's needed.
  300. # Also delete any procedures that are listed in the auto-load index
  301. # except those defined in this file.
  302. #
  303. # Arguments: 
  304. # None.
  305.  
  306. proc auto_reset {} {
  307.     global auto_execs auto_index auto_oldpath
  308.     foreach p [info procs] {
  309.     if {[info exists auto_index($p)] && ![string match auto_* $p]
  310.         && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
  311.             tclPkgUnknown} $p] < 0)} {
  312.         rename $p {}
  313.     }
  314.     }
  315.     catch {unset auto_execs}
  316.     catch {unset auto_index}
  317.     catch {unset auto_oldpath}
  318. }
  319.  
  320. # auto_mkindex --
  321. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  322. # the name of the directory in which the tclIndex file is to be placed,
  323. # followed by any number of glob patterns to use in that directory to
  324. # locate all of the relevant files.
  325. #
  326. # Arguments: 
  327. # dir -            Name of the directory in which to create an index.
  328. # args -        Any number of additional arguments giving the
  329. #            names of files within dir.  If no additional
  330. #            are given auto_mkindex will look for *.tcl.
  331.  
  332. proc auto_mkindex {dir args} {
  333.     global errorCode errorInfo
  334.     set oldDir [pwd]
  335.     cd $dir
  336.     set dir [pwd]
  337.     append index "# Tcl autoload index file, version 2.0\n"
  338.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  339.     append index "# and sourced to set up indexing information for one or\n"
  340.     append index "# more commands.  Typically each line is a command that\n"
  341.     append index "# sets an element in the auto_index array, where the\n"
  342.     append index "# element name is the name of a command and the value is\n"
  343.     append index "# a script that loads the command.\n\n"
  344.     if {$args == ""} {
  345.     set args *.tcl
  346.     }
  347.     foreach file [eval glob $args] {
  348.     set f ""
  349.     set error [catch {
  350.         set f [open $file]
  351.         while {[gets $f line] >= 0} {
  352.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  353.             append index "set [list auto_index($procName)]"
  354.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  355.         }
  356.         }
  357.         close $f
  358.     } msg]
  359.     if $error {
  360.         set code $errorCode
  361.         set info $errorInfo
  362.         catch {close $f}
  363.         cd $oldDir
  364.         error $msg $info $code
  365.     }
  366.     }
  367.     set f ""
  368.     set error [catch {
  369.     set f [open tclIndex w]
  370.     puts $f $index nonewline
  371.     close $f
  372.     cd $oldDir
  373.     } msg]
  374.     if $error {
  375.     set code $errorCode
  376.     set info $errorInfo
  377.     catch {close $f}
  378.     cd $oldDir
  379.     error $msg $info $code
  380.     }
  381. }
  382.  
  383. # pkg_mkIndex --
  384. # This procedure creates a package index in a given directory.  The
  385. # package index consists of a "pkgIndex.tcl" file whose contents are
  386. # a Tcl script that sets up package information with "package require"
  387. # commands.  The commands describe all of the packages defined by the
  388. # files given as arguments.
  389. #
  390. # Arguments:
  391. # dir -            Name of the directory in which to create the index.
  392. # args -        Any number of additional arguments, each giving
  393. #            a glob pattern that matches the names of one or
  394. #            more shared libraries or Tcl script files in
  395. #            dir.
  396.  
  397. proc pkg_mkIndex {dir args} {
  398.     global errorCode errorInfo
  399.     append index "# Tcl package index file, version 1.0\n"
  400.     append index "# This file is generated by the \"pkg_mkIndex\" command\n"
  401.     append index "# and sourced either when an application starts up or\n"
  402.     append index "# by a \"package unknown\" script.  It invokes the\n"
  403.     append index "# \"package ifneeded\" command to set up package-related\n"
  404.     append index "# information so that packages will be loaded automatically\n"
  405.     append index "# in response to \"package require\" commands.  When this\n"
  406.     append index "# script is sourced, the variable \$dir must contain the\n"
  407.     append index "# full path name of this file's directory.\n"
  408.     set oldDir [pwd]
  409.     cd $dir
  410.     foreach file [eval glob $args] {
  411.     # For each file, figure out what commands and packages it provides.
  412.     # To do this, create a child interpreter, load the file into the
  413.     # interpreter, and get a list of the new commands and packages
  414.     # that are defined.  Define an empty "package unknown" script so
  415.     # that there are no recursive package inclusions.
  416.  
  417.     set c [interp create]
  418.  
  419.     # If Tk is loaded in the parent interpreter, load it into the
  420.     # child also, in case the extension depends on it.
  421.  
  422.     foreach pkg [info loaded] {
  423.         if {[lindex $pkg 1] == "Tk"} {
  424.         $c eval {set argv {-geometry +0+0}}
  425.         load [lindex $pkg 0] Tk $c
  426.         break
  427.         }
  428.     }
  429.     $c eval [list set file $file]
  430.     if [catch {
  431.         $c eval {
  432.         proc dummy args {}
  433.         package unknown dummy
  434.         set origCmds [info commands]
  435.         set dir ""        ;# in case file is pkgIndex.tcl
  436.         set pkgs ""
  437.  
  438.         # Try to load the file if it has the shared library extension,
  439.         # otherwise source it.  It's important not to try to load
  440.         # files that aren't shared libraries, because on some systems
  441.         # (like SunOS) the loader will abort the whole application
  442.         # when it gets an error.
  443.  
  444.         if {[string compare [file extension $file] \
  445.             [info sharedlibextension]] == 0} {
  446.  
  447.             # The "file join ." command below is necessary.  Without
  448.             # it, if the file name has no \'s and we're on UNIX, the
  449.             # load command will invoke the LD_LIBRARY_PATH search
  450.             # mechanism, which could cause the wrong file to be used.
  451.  
  452.             load [file join . $file]
  453.             set type load
  454.         } else {
  455.             source $file
  456.             set type source
  457.         }
  458.         foreach i [info commands] {
  459.             set cmds($i) 1
  460.         }
  461.         foreach i $origCmds {
  462.             catch {unset cmds($i)}
  463.         }
  464.         foreach i [package names] {
  465.             if {([string compare [package provide $i] ""] != 0)
  466.                 && ([string compare $i Tcl] != 0)
  467.                 && ([string compare $i Tk] != 0)} {
  468.             lappend pkgs [list $i [package provide $i]]
  469.             }
  470.         }
  471.         }
  472.     } msg] {
  473.         puts "error while loading or sourcing $file: $msg"
  474.     }
  475.     foreach pkg [$c eval set pkgs] {
  476.         lappend files($pkg) [list $file [$c eval set type] \
  477.             [lsort [$c eval array names cmds]]]
  478.     }
  479.     interp delete $c
  480.     }
  481.     foreach pkg [lsort [array names files]] {
  482.     append index "\npackage ifneeded $pkg\
  483.         \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
  484.         [list $files($pkg)]\]"
  485.     }
  486.     set f [open pkgIndex.tcl w]
  487.     puts $f $index
  488.     close $f
  489.     cd $oldDir
  490. }
  491.  
  492. # tclPkgSetup --
  493. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  494. # as part of a "package ifneeded" script.  It calls "package provide"
  495. # to indicate that a package is available, then sets entries in the
  496. # auto_index array so that the package's files will be auto-loaded when
  497. # the commands are used.
  498. #
  499. # Arguments:
  500. # dir -            Directory containing all the files for this package.
  501. # pkg -            Name of the package (no version number).
  502. # version -        Version number for the package, such as 2.1.3.
  503. # files -        List of files that constitute the package.  Each
  504. #            element is a sub-list with three elements.  The first
  505. #            is the name of a file relative to $dir, the second is
  506. #            "load" or "source", indicating whether the file is a
  507. #            loadable binary or a script to source, and the third
  508. #            is a list of commands defined by this file.
  509.  
  510. proc tclPkgSetup {dir pkg version files} {
  511.     global auto_index
  512.  
  513.     package provide $pkg $version
  514.     foreach fileInfo $files {
  515.     set f [lindex $fileInfo 0]
  516.     set type [lindex $fileInfo 1]
  517.     foreach cmd [lindex $fileInfo 2] {
  518.         if {$type == "load"} {
  519.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  520.         } else {
  521.         set auto_index($cmd) [list source [file join $dir $f]]
  522.         } 
  523.     }
  524.     }
  525. }
  526.  
  527. # tclPkgUnknown --
  528. # This procedure provides the default for the "package unknown" function.
  529. # It is invoked when a package that's needed can't be found.  It scans
  530. # the auto_path directories looking for pkgIndex.tcl files and sources any
  531. # such files that are found to setup the package database.
  532. #
  533. # Arguments:
  534. # name -        Name of desired package.  Not used.
  535. # version -        Version of desired package.  Not used.
  536. # exact -        Either "-exact" or omitted.  Not used.
  537.  
  538. proc tclPkgUnknown {name version {exact {}}} {
  539.     global auto_path
  540.  
  541.     if ![info exists auto_path] {
  542.     return
  543.     }
  544.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  545.     set dir [lindex $auto_path $i]
  546.     set file [file join $dir pkgIndex.tcl]
  547.     if [file readable $file] {
  548.         source $file
  549.     }
  550.     }
  551. }
  552.